home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
TOOLKI.ARJ
/
TOOLS.PRG
< prev
Wrap
Text File
|
1991-01-07
|
29KB
|
1,358 lines
*****
* first
* returns the first atom of a list expression
*****
FUNCTION first
PARAMETER list
list = ALLTRIM(list)
sendBack = iif( " " $ list, substr(list,1,at(" ",list)-1), list)
return sendBack
*****
* butfirst
* returns all but the first atom of a list string expression
*****
FUNCTION butfirst
PARAMETER list
list = ALLTRIM(list)
sendback = iif( " " $ list, right(list,len(list)-at(" ",list)), "")
return alltrim(sendBack)
*****
* tail
* returns the last atom of a list string expression
*****
FUNCTION tail
PARAMETER list
list = ALLTRIM(list)
sendBack = iif( " " $ list, right(list,len(list)-rat(" ",list)), list)
return sendBack
*****
* item
* seeks <expN> atom in a list
*****
function item
parameters list,whichOne
for i = 1 to whichOne - 1
list = butfirst(list)
next
return alltrim(first(list))
*****
* atoms
* returns the number of atoms in a list
*****
function atoms
parameters list
count = 0
do while .not. empty(list)
list = butfirst(list)
count = count + 1
enddo
return count
*****
function depth
*****
parameter namedArray,limit
for i = 1 to limit
if empty(&namedArray(i))
exit
endif
next
return i-1
*****
function military
*****
*- takes a string variable of the form ##:##XX ie, 4:45pm, 5:30am
*- and returns a string in military time, ie, 1645, 0530
parameter Time12
time24 = alltrim(str(val(left(Time12,2)) + ;
iif(right(Time12,2) = "am", 0, 12))) + ;
padl(alltrim(str((val(substr(Time12,4,2)) / 60) * 100)),2,"0")
if left(time24,2) = "12"
time24 = stuff(time24,1,2,"00")
endif
if left(time24,2) = "24"
time24 = stuff(time24,1,2,"12")
endif
return Time24
*****
function Odometer
*****
parameters parm1, parm2, parm3, parm4,;
parm5, parm6, parm7, parm8, parm9, parm10
array = 0
xLoc = 0
yLoc = 0
length = 0
pictString = ""
select i &&- We now need to open odometer.dbf
use odometer &&- contains odometer table
handle = 0 &&- the handle of whichever odometer
**- is being used
*/ Parsing of the message
parm1 = lower(parm1) &&- put the message into lower case
**- for consistency
do case
case parm1 = "setup"
do setod &&- sets up odometer, returns handle
case parm1 = "roll"
do roll &&- rolls an odometer up or down
case parm1 = "add"
do add &&- adds a new entry to the array
case parm1 = "menu"
do menu &&- makes a cute little menu
case parm1 = "edit"
do edit &&- edits current entry
case parm1 = "close"
do close &&- closes odometer by handle
case parm1 = "delete"
do del &&- deletes current entry
case parm1 = "refresh"
do refreshHandle &&- refreshes the odometer
endcase
use &&- closes the dbf
return handle &&- handle of the odometer for
**- the calling program's reference
*****
proc menu
*****
handle = parm2 &&- get the handle
success = getHandle() &&- get handle data
if arrayDepth <= 1 &&- if array is too small
return &&- no sense making a menu!
endif
**- define the menu and its bars
define popup ArrayMenu from xloc,yloc
for i = 1 to arrayDepth
define bar i of arrayMenu prompt dtoc(&array(i))
next
on selection popup arrayMenu deactivate popup arrayMenu
activate popup arrayMenu
if .not. empty(prompt())
record = bar() &&- array element <record> chosen
replace recordNo with record &&- select that element
endif
do fieldSay &&- put it on the screen
return
*****
proc refreshHandle
*****
handle = parm2 &&- get the handle
success = getHandle() &&- get handle data
do refreshOd
RETURN
*****
procedure setod
*****
array = parm2 &&- isolate the name of the array
xLoc = parm4 &&- the row it wants to happen at
yLoc = parm5 &&- the column it wants to happen at
maxEntries = parm7 &&- the max number of entries
length = parm9 &&- the length of each entry
pictString = parm10 &&- picture string for entering
if pictstring = .F.
pictstring = ""
endif
arrayDepth = depth(array,maxEntries) &&- discern the depth of the array
if arrayDepth > 0 &&- if there's nothing in the
record = 1 &&- array, we should let other
else &&- parts of the program know
record = 0 &&- so we set record to 0
endif
if eof() &&- determine the handle number
handle = 1 &&- to use.
else
goto bottom
handle = dhandle + 1
endif
*/ create a descriptive entry in the odometer table
append blank
replace ;
dhandle with handle, ;
arrayName with array, ;
xLocation with xloc, ;
yLocation with yloc, ;
recordNo with record, ;
Max with MaxEntries, ;
recordLen with length, ;
Depth with arrayDepth, ;
dbPict with pictString
do refreshOd
return
*****
proc refreshOd
*****
*/ Put the display box onscreen
@xLoc-1 ,yLoc-1 to xLoc + 1, yLoc + length double
*/ put the entry on screen
do fieldSay
RETURN
*****
procedure roll
*****
command = parm2 &&- find either "up" or "down"
handle = parm3 &&- get the handle we're working with
success = getHandle() &&- load our public variables with
&&- information found under the handle
if command = "up"
if record < max .and. ;
record < arrayDepth .and. ;
record > 0 &&- if in an acceptable range & >0
record = record + 1 &&- move forward one
replace recordNo with record &&- make sure our file is updated
else
do beepError &&- can't do that!
endif
else
if command = "down"
if record > 1 &&- if in an acceptable range
record = record - 1 &&- move back one
replace recordNo ;
with record &&- update file
else
do beepError &&- can't do that!
endif
else
do dunno with "understand commands to roll"
endif
endif
*/ update the screen
do fieldSay
return
*****
procedure edit
*****
handle = parm2 &&- get the handle
if record > 0 &&- check for acceptable value
success = getHandle() &&- get handle data
do fieldEdit
else
do beepError &&- can't do it!
endif
return
*****
procedure add
*****
handle = parm2 &&- get the handle
success = getHandle() &&- get handle data
if arrayDepth < maxEntries &&- make sure we're allowed
arrayDepth = arrayDepth + 1 &&- to do this
record = arrayDepth &&- add the record
do fieldEdit &&- edit it
replace Depth with arrayDepth &&- update the file!
replace RecordNo with record
else
do beepError &&- can't do it!
endif
return
*****
procedure del
*****
handle = parm2 &&- get our handle
success = getHandle() &&- get the handle data
if record > 0 &&- if there are records
if record # arrayDepth &&- if it's not the last one
&array(record) = &array(arrayDepth) &&- last becomes the one
if type(array) = "C"
&array(arrayDepth) = "" &&- we just deleted
else &&- Oi! Date's assumed
&array(arraydepth) = { / / }
endif
arrayDepth = arrayDepth - 1 &&- delete it and
replace depth with arrayDepth &&- update the file
else
if type(array) = "C"
&array(arrayDepth) = "" &&- if it is the last one
else &&- (Oi! Date's assumed)
&array(arraydepth) = { / / }
endif
arrayDepth = arrayDepth - 1 &&- just delete it and
record = record - 1 &&- update our data and file
replace depth with arrayDepth
replace recordNo with record
endif
else
do beepError &&- can't do it
endif
do fieldSay
return
*****
procedure close
*****
handle = parm2
success = getHandle()
@xLoc-1 ,yLoc-1 clear to xLoc + 1, yLoc + length &&- clear the odometer
use odometer exclusive &&- clear out odometer.dbf
delete record recno()
pack
use odometer
return
*****
procedure fieldEdit
*****
select g &&- empty workspace
if type(array) = "C" &&- if it's character data
tempSpace = space(length) &&- get it and read it
@xLoc,yLoc GET tempSpace picture pictString
READ
else &&- Oi! we're assuming date!
tempSpace = { / / } &&- don't let a date which
&&- predates today be entered
* @xLoc,yLoc GET tempSpace valid tempSpace > date() - 7
@xLoc,yLoc GET tempSpace
READ
endif
for doIt = 1 to arrayDepth &&- do not permit duplicates
if &array(doIt) = tempSpace .and. doIt <> record
do dunno with "Allow you to enter duplicate fields!"
do fieldedit
return
endif
next
&array(record) = tempSpace
do fieldSay
select i &&- odometer's workspace
return
*****
procedure fieldSay
*****
**- put the field in the odometer box
if record > 0
if type(array) = "C"
@xloc,yloc say left(&array[record],length)
else
@xloc, yloc say &array[record]
endif
else
@xloc,yloc say space(length)
endif
return
*****
function getHandle
*****
**- retrieve the data associated with the handle
locate for dhandle = handle
if .not. found()
do dunno with "know where to find your handle"
cancel
endif
array = arrayName
xLoc = xLocation
yLoc = yLocation
record = recordNo
maxEntries = max
length = recordLen
arrayDepth = Depth
pictString = dbPict
return .t.
*****
* ALERT
* Creates a dialogue box w/buttons
* ALERT returns either 1, 2, or 3
*****
function alert
parameters form,first,second,third,question1,question2,question3
form = lower(form)
DEFINE WINDOW answerWindow ;
FROM 8,15 TO 17,65 float DOUBLE color scheme 14 &&Make the window
**- define ANSWERMENU and its pads
DEFINE MENU answerMenu color scheme 14
IF lower(first)<>"null"
first = prButton(first)
DEFINE PAD a OF answerMenu ;
PROMPT first AT 7,1
ON SELECTION PAD a OF answerMenu ;
DEACTIVATE MENU answerMenu
ENDIF
IF lower(second)<>"null"
second= prButton(second)
DEFINE PAD b OF answerMenu ;
PROMPT second AT 7,16
ON SELECTION PAD b OF answerMenu ;
DEACTIVATE MENU answerMenu
ENDIF
IF lower(third)<>"null"
third= prButton(third)
DEFINE PAD c OF answerMenu ;
PROMPT third AT 7,32
ON SELECTION PAD c OF answerMenu ;
DEACTIVATE MENU answerMenu
ENDIF
ACTIVATE WINDOW answerWindow &&Open the window
do ikon with form,0,0 &&- display the chosen icon
if .not. empty(question1)
@ 1,10 say question1
endif
if .not. empty(question2)
@ 2,10 say question2
endif
if .not. empty(question3)
@ 3,10 say question3
endif
fini = 0
do while fini = 0
ACTIVATE MENU answerMenu &&Turn on the menu
if .not. empty(pad())
fini = 1
endif
enddo
DEACTIVATE WINDOW answerWindow &&Clear the window
RELEASE WINDOW answerWindow
RELEASE MENU answermenu
return asc(pad()) - 64
*****
function prButton
*****
parameters string
string = LEFT(string,10)
string = padc(string,10)
string = "<" + string + ">"
return string
*****
proc ikon
*****
parameters icon, x, y
do case
case icon = "wait"
@x+1,y+3 say "█"
@x+2,y+3 say "█"
@x+3,y+3 say "█"
@x+4,y+3 say "▄"
case icon = "dialogue"
@x+0,y+1 say "┌───┐"
@x+1,y+1 say "│ └┐"
@x+2,y+1 say "│ ┌┘"
@x+3,y+1 say "│ ┌┘"
@x+4,y+1 say "│ └┐"
@x+5,y+1 say "└───┘"
case icon = "unhappy"
@x+0,y+1 say "┌───┐"
@x+1,y+1 say "│ └┐"
@x+2,y+1 say "│ ┌┘"
@x+3,y+1 say "│ ┌─┤"
@x+4,y+1 say "│ │"
@x+5,y+1 say "└───┘"
case icon = "happy"
@x+0,y+1 say "┌───┐"
@x+1,y+1 say "│ └┐"
@x+2,y+1 say "│ ┌┘"
@x+3,y+1 say "│ └─┤"
@x+4,y+1 say "│ │"
@x+5,y+1 say "└───┘"
case icon = "question"
@x+1,y+1 say " ┌───┐"
@x+2,y+1 say "│ │ ? │"
@x+3,y+1 say "└─┼───┘"
@x+4,y+1 say " └───"
endcase
return
*****
procedure explode
*****
parameters startx,starty,endx,endy,endheight,endwidth
for i = 1 to 100 step 10
percent = i * .01
y = starty + ((endy - starty) * percent)
x = startx + ((endx - startx) * percent)
define window stretch from x,y to ;
x+ceiling(endheight*percent),;
y+ceiling(endwidth*percent)
show window stretch
hide window stretch
next
release window stretch
return
*****
proc tedit
* Creates a dialogue box
* Syntax
* "title justification prompt|variable|picture ..."
* title - should be the name of a string variable which
* contains the title string. It should be no more than 90
* chars long.
* justification- centered, left, or right: for the variable's say/get
* prompt- the name of a string variable containing the prompt
* for the following variable
* variable- the name of the string variable you want to store
* data in. should be initialized to the length you
* want.
* picture- a picture string, such as XXXXX. As of now, it should
* contain no spaces. Spaces can be replaced with an X
*
* You can include as many prompt|variable|picture combinations as
* screen space will allow!
*****
PARAMETERS message
message = lower(message) &&- put it in lowercase
numOfFields = atoms(message) - 2 &&- number of fields
question = first(message) &&- title for query box
question = &question &&- macro de-embedding
DEFINE WINDOW answerWindow ;
FROM 10,15 TO 14 + numOfFields,63 DOUBLE ;
COLOR SCHEME 15 &&- Make the window
ACTIVATE WINDOW answerWindow &&Open the window
do divq with question,46
for askem = 1 to numOfFields &&- do for each field
variable = item(message,askem+2) &&- get the data
firstDelim = at("|",variable) &&- find first |
secondDelim = rat("|",variable) &&- find second |
prompt = left(variable,firstDelim-1) &&- what to say
pictstr = right(variable,len(variable) - secondDelim)
if pictstr = "none"
pictstr = ""
endif
*/ get the variable name /*
macroVar = substr(variable,firstDelim+1,secondDelim-firstDelim-1)
just = first(butfirst(message)) &&- determine the
do case &&- justification
case just = "right"
getAt = 47-len(&prompt+¯oVar)
case just = "left"
getAt = 1
case just = "center"
getAt = 23-len(&prompt+¯oVar)/2
endcase
@1+askem,getAt say &prompt get ¯ovar picture pictstr
next
read
DEACTIVATE WINDOW answerWindow &&Clear the window
RELEASE WINDOW answerWindow
*****
function getTime
*****
parameters xLocation,yLocation
timeToGet = " "
@xLocation,yLocation ;
get timeToGet picture "##:##!!" valid timetest(timeToGet)
read
timetoGet = lower(timeToGet)
**- align the hours and/or clear up any leading zeroes
timeToGet = padl( alltrim( str( val( left( timeToGet,2)))), 2) + ;
right( timeToGet, 5)
@xlocation, ylocation say timeToGet
return timeToGet
*****
function timetest
*****
parameter timeToTest
hours = val(left(timeToTest,2))
if .not. between(hours,1,12)
return .f.
endif
minute = val(substr(timeToTest,4,2))
if .not. between(minute,0,45)
return .f.
endif
if .not. mod(minute,15) = 0
return .f.
endif
ampm = right(timeToTest,2)
if .not. (ampm = "AM" .or. ampm = "PM")
return .f.
endif
return .t.
*****
function tick
*****
PARAMETERS row,column,tickedString
*Expecting Mprompts to be an array equal in elements to the length
*of tickedString
DEFINE POPUP tickEr FROM row,column color scheme 12
FOR iteration = 1 TO LEN(tickedString)
flag = substr(tickedString,iteration,1)
if flag = "0"
thisPrompt= " " + Mprompts(iteration)
DEFINE BAR iteration OF tickEr ;
PROMPT thisPrompt SKIP
else
thisPrompt=flag + " " + Mprompts(iteration)
DEFINE BAR iteration OF tickEr ;
PROMPT thisPrompt
endif
NEXT
ON SELECTION POPUP tickEr DO tickEt
ACTIVATE POPUP tickEr
release popup tickEr
RETURN tickedString
*****
* PROCEDURE tickET
* ticks a spot on the popup, and resets the string variable
*****
PROCEDURE tickET
IF SUBSTR(tickedString,BAR(),1)="√"
tickedString=LEFT(tickedString,BAR()-1)+" "+SUBSTR(tickedString,BAR()+1)
ELSE
tickedString=LEFT(tickedString,BAR()-1)+"√"+SUBSTR(tickedString,BAR()+1)
ENDIF
deactivate POPUP tickEr
RETURN
*****
function inrange
*- determines if the two time ranges expressed in the parameters overlap
*- parameters must be 24 hour times in format "0845" or "1245"
*****
parameters first,second,third,fourth
second = iif(second < first, second + 2400, second)
fourth = iif(fourth < third, fourth + 2400, fourth)
if between(first,third,fourth) ;
.or. between(second,third,fourth) ;
.or. between(third,first,second) ;
.or. between(fourth,first,second)
result = .t.
else
result = .f.
endif
return result
*****
proc chooser
*****
do objects
acti window chooser
do printerIkon
acti menu chooser pad &chosenPrin
release window chooser
*****
proc choose
*****
chosenPrinter = upper(pad())
do case
case chosenPrinter = "DOTMATRIX"
set printer to \\lpt1\p=0
case chosenPrinter = "LASER"
set printer to \\lpt1\p=2
case chosenPrinter = "LOCAL"
!endcap > nul
endcase
do printerIkon
RETURN
*****
proc objects
*****
*- defines objects such as menus and windows
*- window for chooser
define window chooser from 5,20 to 15,60 title "Oat Bran Chooser" color scheme 17
*- menu to choose printer
define menu chooser color scheme 17
define pad DotMatrix of chooser at 1,3 prompt "Dot Matrix" color scheme 17
on selection pad DotMatrix of chooser do choose
define pad Laser of chooser at 3,3 prompt "Laser" color scheme 17
on selection pad laser of chooser do choose
define pad local of chooser at 5,3 prompt "Local" color scheme 17
on selection pad local of chooser do choose
define pad finished of chooser at 7,3 prompt "Finished" color scheme 17
on selection pad finished of chooser deactivate menu
RETURN
*****
proc printerIkon
*****
@2,20 say " ┌─────┐"
@3,20 say " │LPT1:│"
@4,20 say "┌───▀▀▀▀▀▀▀───┐ ╦"
@5,20 say "│ ■■■■│ ║"
@6,20 say "│ " + padc(chosenPrinter,11) + " ╞═╝"
@7,20 say "└─────────────┘"
RETURN
*****
proc printSetup
*- sets up the chosen Printer
*****
do case
case chosenPrinter = "DOTMATRIX"
do epsonOptions
case chosenPrinter = "LASER"
do laserOptions
case chosenPrinter = "POSTSCRIPT"
* Yeah, right
endcase
***
proc epsonOptions
*- sets up the epson printer
***
chosen = alert ("dialogue", "Underline", "Bold", "Normal", "Style?")
do case
case chosen = 1
do send with chr(27) + chr(45) + chr(1)
case chosen = 2
do send with chr(27) + chr(69)
case chosen = 3
do send with chr(27) + chr(70) + chr(27) + chr(45) + chr(0)
endcase
return
***
proc send
*- sends something to the printer
***
parameters controlString
set print on
set console off
?? controlString
set print off
set console on
return
*****
proc userlist
*****
save screen
define window users from 10,15 to 24,68 title "Userlist" ;
system close float color scheme 8
wait "Please hold on..." Window timeout .5
fileName = "i:" + sys(3)
@ 0,0
!userlist > &fileName
acti screen
restore screen
modi file (filename) window users noedit
erase (fileName)
*****
proc openProgram
*****
parameters progName
@0,0 fill to 0,79 color n/w
@0,0 say padc(progName,79) color n/w
do explode with 12,40,0,0,24,79
activate screen &&- just in case some windows are around
clear
RETURN
*****
proc systemMenu
*****
acti Popup SystemMenu
do case
case bar() = 1
*- about
set compatible foxplus
workArea = str(select())
select 19
use register
modify memo about window about noedit nowait
do while empty(inkey())
enddo
close memo about
use
select &workarea
case bar() = 2
help
case bar() = 4
do chooser
case bar() = 5
do userlist
endcase
RETURN
*****
procedure shrink
*****
parameters startx,starty,endx,endy,endheight,endwidth
for i = 100 to 1 step -10
percent = i * .01
y = starty + ((endy - starty) * percent)
x = startx + ((endx - startx) * percent)
define window stretch from x,y to ;
x+ceiling(endheight*percent),;
y+ceiling(endwidth*percent)
show window stretch
hide window stretch
next
release window stretch
return
*****
proc divQ
*****
parameters question, length
qLength = len(question)
if qLength > length
if mod(qLength,2) # 0
question = question + " "
qLength = qLength + 1
endif
searchArea = substr(question,qLength/2,length/2)
whereSpace = at(" ",searchArea) + qLength/2 -1
question1 = left(question, wherespace-1)
question2 = right(question,qLength-whereSpace)
@0,0 say padc(alltrim(question1),length)
@1,0 say padc(alltrim(question2),length)
else
@0,0 say padc(question,length)
endif
return
*****
proc beepError
*****
@0,0 fill to 0,79 color w/n
for i = 1 to 200
next
wait window "Yo!" timeout .001
@0,0 fill to 0,79 color n/w
*****
* Yo
* Creates a dialogue box
* Very important that passed parameters meet syntax!
*
*****
function Yo
parameters form,delayLength,question1,question2,question3
form = lower(form)
DEFINE WINDOW answerWindow ;
FROM 8,15 TO 17,65 float DOUBLE color scheme 8 &&Make the window
*do explode with 12,40,8,15,9,50
ACTIVATE WINDOW answerWindow &&Open the window
do ikon with form,0,0
if .not. empty(question1)
@ 1,10 say question1
endif
if .not. empty(question2)
@ 2,10 say question2
endif
if .not. empty(question3)
@ 3,10 say question3
endif
= inkey(delayLength)
DEACTIVATE WINDOW answerWindow &&Clear the window
RELEASE WINDOW answerWindow
return .t.
*****
function card
*****
*- card permits us to set up a screen o' buttons from a definition file */
*- Variables:
*- message: Sent from calling program. Used as return variable
*- when telling the caller that success was obtained.
*- databaseName: Public. Contains the name of the database which
*- is being used by card.
*- buttons[x,x]: Public. Array containing button information where:
*- buttons[x,1] is the row of the button
*- buttons[x,2] is the left column
*- buttons[x,3] is the right column
*- buttons[x,4] is the enable/disable flag
*- buttons[x,5] is the button name
*- buttonLimit: Public. Number of buttons found in the database
*- counter: A loop control variable. Counts through numbered
*- buttons designated by buttonLimit
*- disabled: Found in check() If true, then check will ignore
*- option disabling. If false, then check will ignore
*- any button which is shut off
*- clicked: simply a variable which allows us to call inkey
*- hit: the number of the button which was hit
*- buttonToDisable:the number of the button to be disabled
*- buttonToEnable: the number of the button to enable
*-
*- Syntax of commands:
*- x = card("setup <expc>")
*- initializes and displays a card which is configured in
*- the database named <expc>
*- hit = card("check [disabled]")
*- checks the mouse for a button hit. the disabled option ignores
*- button disabling.
*- x = card("disable <expn>")
*- disables button number <expn>
*- x = card("enable <expn>")
*- enables button number <expn>. Buttons default to enabled status.
*- in order for card to work, procedure must be set to PARSE
parameters message
message = lower(message)
*- message is the command sent to CARD
*- Parse it in lowercase for uniformity
firstone = first(message)
do case
case firstone = "setup"
do doCard
case firstone = "check"
message = check()
if message # 0 .and. message # 255
do flash
endif
case firstone = "disable"
do disable
case firstone = "enable"
do enable
case firstOne = "close"
release buttons, buttonLimit
case firstOne = "refresh"
do refresh
endcase
select j
use
return message
*****
procedure doCard
*****
*/ butfirst(message) better equal the name of a configuration dbf */
*/ or this will send back an error message */
databaseName = butfirst(message)
if file(databaseName + ".dbf")
select j
use (databaseName)
do checkDatabase
else
do dunno with "know where to find your database named " + databaseName
message = .f.
endif
return message
*****
procedure checkDatabase
*****
*/ this will check to see if the database if a proper configuration one */
if .not. ;
(field(1) = "ROW" .AND. ;
field(2) = "COLUMN" .AND. ;
field(3) = "BUTTON")
do dunno with "think that " + databaseName + " is a proper configuration file"
message = .f.
else
do prepare
do refresh
endif
return message
*****
procedure prepare
*****
release buttonLimit
release buttons
public buttons
public buttonlimit
buttonLimit = reccount()
dimension buttons[buttonLimit,5]
for counter = 1 to buttonLimit
goto counter
*/ now store it in memory */
buttons[counter,1] = row &&- row location
buttons[counter,2] = column &&- left column
buttonLength = len(allTrim(button)) &&- length of button helps
buttons[counter,3]=column+buttonLength-1 &&- us determine right column
buttons[counter,4] = .T. &&- This is the enable
buttons[counter,5] = alltrim(button) &&- This is the buttonname
next (counter = 1 to buttonLimit)
message = .t.
select j
use
return
***
function check
***
if butfirst(message) = "disabled" &&- checks for disabled items
disabled = .t.
else
disabled = .f.
endif
clicked = 666
*/ let's wait for a mouse click */
do while clicked <> 151 .and. .not. between(clicked,1,26)
clicked = inkey("M")
enddo
row = mrow() &&- Store row and column of mouse pointer
col = mcol()
*/ let's see if it's a doubleClick */
clicked = inkey(.25, "M")
if clicked <> 0
dblClick = -1
else
dblClick = 1
endif
for counter = 1 to buttonLimit &&- From first button to the last
if row=buttons[counter,1] ;
.and. ;
between(col,buttons[counter,2],buttons[counter,3]) ;
.and. ;
(buttons[counter,4] .or. disabled)
exit
endif
next
if counter > buttonLimit
counter = 0
endif
return counter*dblClick
***
procedure refresh
***
for counter = 1 to buttonLimit
*/ display it on the screen */
do sayAButton with counter
next (counter = 1 to buttonLimit)
return
***
procedure disable
***
firstButton = first(butfirst(message))
if .not. type(firstbutton) = "N"
if butfirst(message) = "all"
FirstButton = 1
lastButton = buttonLimit
else
do dunno with "understand alpha commands to disable"
endif
else
firstButton = abs(val(firstButton))
if .not. empty(tail(message))
lastbutton = abs(val(tail(message)))
else
lastButton = firstButton
endif
endif
for i = firstButton to LastButton
buttons[i,4] = .F.
do sayAButton with i
next
return
***
procedure enable
***
firstButton = first(butfirst(message))
if .not. type(firstbutton) = "N"
if butfirst(message) = "all"
FirstButton = 1
lastButton = buttonLimit
else
do dunno with "understand alpha commands to disable"
endif
else
firstButton = abs(val(firstButton))
if .not. empty(tail(message))
lastbutton = abs(val(tail(message)))
else
lastButton = firstButton
endif
endif
for i = firstButton to LastButton
buttons[i,4] = .T.
do sayAButton with i
next
return
***
proc flash
***
But = abs(message)
@buttons(but,1), buttons(but,2) ;
fill to buttons(but,1), buttons(but,3) color n/w*
if buttons[but,1] = 0
@buttons(but,1), buttons(but,2) ;
fill to buttons(but,1), buttons(but,3) color n/w
else
@buttons(but,1), buttons(but,2) ;
fill to buttons(but,1), buttons(but,3) color gr+/b
endif
return
***
proc sayAButton
***
parameter buttonToSay
do case
case buttons[buttonToSay,4] = .F. &&- disabled
@buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
buttons[buttonToSay,5] color n+/b
case buttons[buttonToSay,1] = 0 &&- if it's in the top row,
@buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
buttons[buttonToSay,5] color n/w &&- it's part of the system menu
otherwise
@buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
buttons[buttonToSay,5] color gr+/b &&- normal color
endcase